Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/ISSUE08/DATADICT/UTILS.PAS

Pascal/Delphi Source File | 1996-02-07 | 10.5 KB | 397 lines

unit Utils;
interface
uses sysutils, wintypes,Dialogs, graphics, grids;
const
  IntegerSet : set of ' '..'z' = ['1','2','3','4','5','6','7','8','9','0','-'];
  RealSet : set of ' '..'z' = ['1','2','3','4','5','6','7','8','9','0','-','.','+','E'];
  WordSet : set of ' '..'z' = ['1','2','3','4','5','6','7','8','9','0'];
const
  fmt_10n = '%10.0n';
  fmt_left10n = '%-10.0n';
  pctfmt    = '%3d%%';

type                            { from DOS.PAS, RTL 5.5, BP7}
  PathStr = string[79];         { File pathname string }
  DirStr  = string[67];         { Drive and directory string }
  NameStr = string[8];          { File name string }
  ExtStr  = string[4];          { File extension string }
type
  charset = SET OF CHAR;
var
  pathholder : pathstr;
  Dirholder  : dirstr;
  nameholder : namestr;
  extholder  : extstr;

{Stringlist & Grid}

procedure AdjustColWidth(const whichcol : integer; var whichgrid : TstringGrid);

{File name stuff}

function AddBackSlash(const S: String): String;
function StripBackSlash(const S: String): String;
function appName : string; {path of application less extension}

{String functions}

function noSlashstring(const s: string): string;
function StripSymbol(const s, sym: string): string;
FUNCTION find_next_char_position(of_these_char : charset; workline : STRING; start : BYTE) : BYTE;
FUNCTION trimstr(workstr : STRING) : STRING;
FUNCTION leftstr(in_string : STRING; size : BYTE; pad : CHAR) : STRING;



function plural(const s : string): string;

function MinimizeName(const Filename: TFileName; Canvas: TCanvas;
  MaxLen: Integer): TFileName;  {from filectrl.pas}

{math functions}
function IKMGB(const howbig : longint): string;
function RKMGB(const howbig : real): string;
function maxOf(const first, second : integer):integer;

function isIntegerChar(const whatChar : char) : boolean;
function isRealChar(const whatChar : char) : boolean;
function isWordChar(const whatChar : char): boolean;
function IntToCardinalStr(const number : integer): string;

{Form appearence -- just a stub for now}
Procedure ScaleForm(sender: Tobject);

implementation

uses LZExpand, WinProcs, Forms, Controls,
     stdctrls, buttons;

{======================== stringlist & gird utilities ==================}

procedure AdjustColWidth(const whichcol : integer; var whichgrid : TstringGrid);
var i, x, biggest : integer;
begin with whichgrid do begin
  biggest := 0;
  for i:= 0 to rowcount -1  do
    if canvas.TextWidth(cells[whichCol,i]) > biggest
      then biggest := canvas.textwidth(cells[WhichCol,i]);
  colWidths[longint(whichCol)] := biggest+6;
  end;
end;



function AddBackSlash(const S: String): String;
{ Adds a backslash to string S.  If S is already 255 chars or already has }
{ trailing backslash, then function returns S. }
begin
  if (Length(S) < 255) and (S[Length(S)] <> '\') then
    Result := S + '\'
  else
    Result := S;
end;

function StripBackSlash(const S: String): String;
{ Removes trailing backslash from S, if one exists }
begin
  Result := S;
  if Result[Length(Result)] = '\' then
    Dec(Result[0]);
end;


function appName : string;
begin
  result := copy(application.exename, 1, pos('.',application.exename)-1);
end;

function noSlashstring(const s: string): string;
{assumes s is a fully qualified filename}
{takes out '\' and '.'}
{alias name max is dbmaxnamelen,31}
var extra : integer;
begin
  result := s[1]+copy(s,3,255);   {extract the :}
  while pos('\',result) <> 0 do
    result := copy(result, 1, pos('\',result)-1)+
              copy(result, pos('\', result)+1, 255);
  result := copy(result, 1, pos('.', result)-1) +
            copy(result, pos('.', result)+1, 255);
  extra := length(result) - 31;
  if extra > 0
    then result := result[1] + copy(result, extra+1, 255);
end;

function StripSymbol(const s, sym: string): string;
{takes out any occurances of symbol}
var extra : integer;
begin
  result := s;
  while pos(sym,result) <> 0 do
    result := copy(result, 1, pos(sym,result)-1)+
              copy(result, pos(sym, result)+1, 255);
end;

FUNCTION trimstr(workstr : STRING) : STRING;
VAR first_char, last_char : INTEGER;
  done : BOOLEAN;
BEGIN
  done := FALSE;
  first_char := 1;
  REPEAT
    IF workstr[first_char] <> ' ' THEN done := TRUE
    ELSE INC(first_char);
  UNTIL done OR (first_char = LENGTH(workstr));
  done := FALSE;
  last_char := LENGTH(workstr);
  REPEAT
    IF workstr[last_char] <> ' ' THEN done := TRUE
    ELSE DEC(last_char);
  UNTIL done OR (last_char = 1);
  trimstr := COPY(workstr, first_char, last_char - first_char + 1);
END;


FUNCTION find_next_char_position(of_these_char : charset; workline : STRING; start : BYTE) : BYTE;
VAR
  i     : INTEGER;
  ch    : CHAR;
  found : boolean;
BEGIN
  found := false;
  FOR i := start TO LENGTH(workline) DO begin
    ch := workline[i];
    IF ch IN of_these_char
      THEN begin found := true; break end;
    end;
  if found
    then result := i
    else result := 0;
END;

FUNCTION leftstr(in_string : STRING; size : BYTE; pad : CHAR) : STRING;
VAR i : INTEGER;
    wrkstr : STRING;
BEGIN
  wrkstr := COPY(trimstr(in_string), 1, size);
  IF LENGTH(wrkstr) < size
  THEN
  BEGIN
    FOR i := LENGTH(wrkstr) TO size - 1 DO
      wrkstr := wrkstr + pad
  END;
  leftstr := wrkstr;
END;

FUNCTION rightstr(in_string : STRING; size : BYTE; pad : CHAR) : STRING;
VAR i : INTEGER;
    wrkstr : STRING;
BEGIN
  i := LENGTH(trimstr(in_string)) - size + 1;
  IF i <= 0 THEN wrkstr := COPY(trimstr(in_string), 1, size)
  ELSE wrkstr := COPY(trimstr(in_string), i, size);
  IF LENGTH(wrkstr) < size
  THEN
  BEGIN
    FOR i := 1 TO (size - LENGTH(wrkstr)) DO
      wrkstr := pad + wrkstr
  END;
  rightstr := wrkstr;
END;




function plural(const s : string): string;
begin end;
{  case s[length(s)] of
    'y' : s := copy(s,}

function CurrentTextWidth(cur_canvas : tcanvas; const whatstr : string): integer;
 var TextMetric : tTextMetric;
begin
  getTextMetrics(cur_canvas.handle, textMetric);
  result := (textMetric.tmAveCharWidth * length(whatstr))+2;
end;

function CurrentTextHeight(cur_canvas : tcanvas): integer;
 var TextMetric : tTextMetric;
begin
  getTextMetrics(cur_canvas.handle, textMetric);
  result := textMetric.tmHeight + textMetric.tmExternalLeading;
end;

 {Generic number formatting}
function IKMGB(const howbig : longint): string;
var i : longint;
    j : real;
const  KBLimit : longint = 1024*1024;
       MBLimit : longint = 1024*1024*1024;

begin
  if howbig < 0
    then result := ' '
    else if howbig < 1024
      then result :=  inttostr(howbig)+ ' bytes'
      else if howbig < KBLimit
        then result := format('%n KB',[1.0*howbig/1024])
        else if howbig < MBLimit
          then result := format('%n MB', [1.0*howbig/(1024*1024)])
          else result := format('%n GB', [1.0*howbig/(1024*1024*1024)]);
 end;

function RKMGB(const howbig : real): string;
var i : longint;
    j : real;
const  KBLimit : real = 1024*1024;
       MBLimit : real = 1024*1024*1024;

begin
  if howbig < 0
    then result := ' '
    else if howbig < 1024
      then result :=  format('%n bytes', [howbig])
      else if howbig < KBLimit
        then result := format('%n KB',[howbig/1024])
        else if howbig < MBLimit
          then result := format('%n MB', [howbig/KBLimit])
          else result := format('%n GB', [howbig/MBLimit]);
 end;


function maxOf(const first, second : integer):integer;
begin
  if first > second
    then result := first
    else result := second;
end;

procedure ChangeToCartesian(var coord : tpoint; const limit : tpoint);
var mid : integer;
begin
  mid := limit.x div 2;
  if coord.x > mid
    then coord.x := coord.x - mid
    else coord.x := - (mid - coord.x);
  mid := limit.y div 2;
  if coord.y > mid
    then coord.y := - (coord.y - mid)
    else coord.y := mid - coord.y;
end;

procedure CartesionToPositiveOnly(var coord : tpoint; const limit : tpoint);
var mid : integer;
begin
  mid := limit.x div 2;
  if coord.x > 0
    then coord.x := mid + coord.x
    else if coord.x < 0
      then coord.x := mid + coord.x
      else coord.x := mid;
  mid := limit.y div 2;
  if coord.y > 0
    then coord.y := mid - coord.y
    else if coord.y < 0
      then coord.y := mid + abs(coord.y)
      else coord.y := mid;
end;



function isIntegerChar(const whatChar : char) : boolean;
begin
  if whatChar in IntegerSet
    then result := true
    else result := false;
end;

function isRealChar(const whatChar : char) : boolean;
begin
  if whatChar in RealSet
    then result := true
    else result := false;
end;

function isWordChar(const whatChar : char): boolean;
begin
  if whatChar in WordSet
    then result := true
    else result := false;
end;

function IntToCardinalStr(const number : integer): string;
begin
  result := intToStr(number);
  if copy(result, length(result), 1) = '1'
    then result := result + 'st'
    else if copy(result, length(result),1) = '2'
      then result := result + 'nd'
      else if copy(result, length(result),1) = '3'
        then result := result + 'rd'
        else result := result + 'th';
end;



 procedure CutFirstDirectory(var S: TFileName);
var
  Root: Boolean;
  P: Integer;
begin
  if S = '\' then S := ''
  else begin
    if S[1] = '\' then
    begin
      Root := True;
      S := Copy(S, 2, 255);
    end else Root := False;
    if S[1] = '.' then S := Copy(S, 5, 255);
    P := Pos('\',S);
    if P <> 0 then S := '...\' + Copy(S, P + 1, 255)
    else S := '';
    if Root then S := '\' + S;
  end;
end;


function MinimizeName(const Filename: TFileName; Canvas: TCanvas;
  MaxLen: Integer): TFileName;
var
  Drive: string[3];
  Dir: TFileName;
  Name: TFileName;
  Ext: TFileName;
  P: Integer;
begin
  Result := FileName;
  Dir := ExtractFilePath(Result);
  Name := ExtractFileName(Result);
  P := Pos('.', Name);
  if P > 0 then Name[0] := Chr(P - 1);
  Ext := ExtractFileExt(Result);

  if Dir[2] = ':' then
  begin
    Drive := Copy(Dir, 1, 2);
    Dir := Copy(Dir, 3, 255);
  end else Drive := '';
  while ((Dir <> '') or (Drive <> '')) and (Canvas.TextWidth(Result) > MaxLen) do
  begin
    if Dir = '\...\' then
    begin
      Drive := '';
      Dir := '...\';
    end else if Dir = '' then Drive := ''
    else CutFirstDirectory(Dir);
    Result := Drive + Dir + Name + Ext;
  end;
end;

{ Scale form ...}
Procedure ScaleForm(sender: Tobject);
begin
  {nothing seems to work very well...}
end;

end.